home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- (macsyma-module nrat4)
-
- (DECLARE-TOP(GENPREFIX FQZ_)
- (SPECIAL $RATSIMPEXPONS *EXP *EXP2 *RADSUBST *LOGLIST $RADSUBSTFLAG
- $RADEXPAND $LOGSIMP *V *VAR FR-FACTOR RADCANP RATSUBVL)
- (*LEXPR $RATSIMP)
- (FIXNUM NARGS))
-
- (LOAD-MACSYMA-MACROS RZMAC RATMAC)
-
- (DEFMVAR $RADSUBSTFLAG NIL
- "RADSUBSTFLAG T makes RATSUBS call RADCAN when it appears useful")
-
-
- (DEFMFUN PDIS (X) ($RATDISREP (PDIS* X)))
-
- (DEFUN PDIS* (X) `((MRAT SIMP ,VARLIST ,GENVAR) ,X . 1))
-
- (DEFUN RDIS (X) ($RATDISREP (RDIS* X)))
-
- (DEFUN RDIS* (X) `((MRAT SIMP ,VARLIST ,GENVAR) . ,X))
-
- (DEFUN RFORM (X) (CDR (RATF X)))
-
- (SETQ RADCANP NIL)
-
- (DEFMFUN $RATCOEF NARGS
- (COND ((= NARGS 3) (RATCOEFF (ARG 1) (ARG 2) (ARG 3)))
- ((= NARGS 2) (RATCOEFF (ARG 1) (ARG 2) 1))
- (T (WNA-ERR '$RATCOEFF)))) ; The spelling "RATCOEFF" is nicer.
-
- (DEFMFUN RATCOEFF (A B C)
- (LET* ((FORMFLAG ($RATP A))
- (TAYLORFORM (AND FORMFLAG (MEMQ 'TRUNC (CDAR A)))))
- (COND ((ZEROP1 B) (IMPROPER-ARG-ERR B '$RATCOEFF))
- ((MBAGP A) (CONS (CAR A)
- (MAPCAR #'(LAMBDA (A) (RATCOEFF A B C))
- (CDR A))))
- ((AND TAYLORFORM (MNUMP C) (ASSOLIKE B (CADDDR (CDAR A))))
- (PSCOEFF1 A B C))
- ((AND TAYLORFORM (MEXPTP B) (MNUMP C) (MNUMP (CADDR B))
- (ASSOLIKE (CADR B) (CADDDR (CDAR A))))
- (PSCOEFF1 A (CADR B) (MUL2 C (CADDR B))))
- ((AND TAYLORFORM (EQUAL C 0)) A)
- (T (IF TAYLORFORM (SETQ A (RATDISREP A)))
- (SETQ A (LET ($RATWTLVL)
- (IF (EQUAL C 0)
- (RATCOEF (MUL2* A B) B)
- (RATCOEF A (IF (EQUAL C 1) B (LIST '(MEXPT) B C))))))
- (IF (AND FORMFLAG (NOT TAYLORFORM))
- (MINIMIZE-VARLIST A)
- (RATDISREP A))))))
-
- (DEFUN MINIMIZE-VARLIST (RATFUN)
- (IF (NOT ($RATP RATFUN)) (SETQ RATFUN (RATF RATFUN)))
- (MINVARLIST-MRAT (CADDR (CAR RATFUN)) (CADDDR (CAR RATFUN))
- (CDR RATFUN)))
-
- (DEFUN MINVARLIST-MRAT (VARS GENS RATFORM)
- (LET ((NEWGENS (UNION* (LISTOVARS (CAR RATFORM))
- (LISTOVARS (CDR RATFORM)))))
- (DO ((LV VARS (CDR LV))
- (LG GENS (CDR LG))
- (NLV ())
- (NLG ()))
- ((NULL LG)
- (CONS (LIST 'MRAT 'SIMP (NREVERSE NLV) (NREVERSE NLG))
- RATFORM))
- (COND ((MEMQ (CAR LG) NEWGENS)
- (PUSH (CAR LG) NLG)
- (PUSH (CAR LV) NLV))))))
-
- (DEFUN RATCOEF (EXP VAR)
- (PROG (VARLIST GENVAR $RATFAC $ALGEBRAIC $RATWTLVL BAS MINVAR)
- (SETQ VAR (RATDISREP VAR))
- (SETQ BAS (IF (AND (MEXPTP VAR) (MNUMP (CADDR VAR))) (CADR VAR) VAR))
- (NEWVAR VAR)
- (NEWVAR BAS)
- (SETQ MINVAR (CAR VARLIST))
- (NEWVAR EXP)
- (SETQ EXP (CDR (RATREP* EXP)))
- (SETQ VAR (CDR (RATREP* VAR)))
- (SETQ BAS (CADR (RATREP* BAS)))
- (IF (AND (ONEP1 (CDR EXP)) (ONEP1 (CDR VAR)) (PUREPROD (CAR VAR)))
- (RETURN (PDIS* (PRODCOEF (CAR VAR) (CAR EXP)))))
- (SETQ EXP (RATQUOTIENT EXP VAR))
- (IF (NULL MINVAR) (RETURN (PDIS* (PRODCOEF (CDR EXP) (CAR EXP)))))
- (SETQ MINVAR (CAADR (RATREP* MINVAR)))
- LOOP (IF (OR (PCOEFP (CDR EXP)) (POINTERGP MINVAR (CADR EXP)))
- (RETURN (RDIS* (CDR (RATDIVIDE EXP BAS)))))
- (SETQ EXP (RATCOEF1 (CAR EXP) (CDR EXP)))
- (GO LOOP)))
-
- (DEFUN RATCOEF1 (NUM DEN)
- (COND ((PCOEFP NUM) (RZERO))
- ((EQ (CAR NUM) (CAR DEN)) (CAR (PDIVIDE NUM DEN)))
- ((POINTERGP (CAR DEN) (CAR NUM)) (RZERO))
- (T (RATCOEF1 (CONSTCOEF (CDR NUM)) DEN))))
-
- (DEFUN CONSTCOEF (P)
- (COND ((NULL P) 0)
- ((ZEROP (CAR P)) (CADR P))
- (T (CONSTCOEF (CDDR P)))))
-
- (SETQ *RADSUBST NIL RATSUBVL T) ;SUBST ON VARLIST
-
- (DEFMFUN $RATSUBST (A B C) ;NEEDS CODE FOR FAC. FORM
- (PROG (VARLIST NEWVARLIST DONTDISREPIT $RATFAC GENVAR)
- ;;hard to maintain user ordering info.
- (IF ($RATP C) (SETQ DONTDISREPIT T))
- (WHEN (AND $RADSUBSTFLAG
- (PROG2 (NEWVAR B) (ORMAPC #'MEXPTP VARLIST)))
- (LET (($FACTORFLAG T) *EXP *EXP2 *RADSUBST)
- (SETQ B (FULLRATSIMP B))
- (SETQ C (FULLRATSIMP C))
- (SETQ VARLIST NIL)
- (FNEWVAR B)
- (FNEWVAR C)
- (SETQ *EXP (CDR (RATREP* B)))
- (SETQ *EXP2 (CDR (RATREP* C)))
- ;; since *radsubst is t, both *exp and *exp2 will be radcan simplified
- (SETQ *RADSUBST T)
- (SPC0)
- (SETQ B (RDIS *EXP) C (RDIS *EXP2))
- (SETQ VARLIST NIL)))
- (SETQ A ($RATDISREP A) B ($RATDISREP B) C ($RATDISREP C))
- (COND ((INTEGERP B) (SETQ C (RATF (MAXIMA-SUBSTITUTE A B C)))
- (RETURN (COND (DONTDISREPIT C) (T ($RATDISREP C))))))
- (NEWVAR C)
- (SETQ
- NEWVARLIST
- (IF RATSUBVL
- (MAPCAR
- #'(LAMBDA (Z)
- (COND ((ATOM Z) Z)
- (T (RESIMPLIFY
- (CONS (CAR Z)
- (MAPCAR #'(LAMBDA (ZZ)
- (COND ((ALIKE1 ZZ B) A)
- ((ATOM ZZ) ZZ)
- (T ($RATDISREP
- ($RATSUBST A B ZZ)))))
- (CDR Z)))))))
- VARLIST)
- VARLIST))
- (NEWVAR A) (NEWVAR B)
- (SETQ NEWVARLIST (REVERSE (PAIROFF (REVERSE VARLIST)
- (REVERSE NEWVARLIST))))
- (SETQ A (CDR (RATREP* A)))
- (SETQ B (CDR (RATREP* B)))
- (SETQ C (CDR (RATREP* C)))
- (WHEN (PMINUSP (CAR B))
- (SETQ B (RATMINUS B))
- (SETQ A (RATMINUS A)))
- (WHEN (AND (EQN 1 (CAR B)) (NOT (EQN 1 (CDR B)))(NOT (EQN (CAR A) 0)))
- (SETQ A (RATINVERT A))
- (SETQ B (RATINVERT B)))
- (COND ((NOT (EQN 1 (CDR B)))
- (SETQ A (RATTIMES A (CONS (CDR B) 1) T))
- (SETQ B (CONS (CAR B) 1))))
- (SETQ C
- (COND ((zl-MEMBER (CAR B) '(0 1))
- (RATF (MAXIMA-SUBSTITUTE (RDIS A) B (RDIS C))))
- (T (CONS (LIST 'MRAT 'SIMP VARLIST GENVAR)
- (IF (EQN (CDR A) 1)
- (RATREDUCE (EVERYSUBST0 (CAR A) (CAR B) (CAR C))
- (EVERYSUBST0 (CAR A) (CAR B) (CDR C)))
- (ALLSUBST00 A B C))))))
- (UNLESS (ALIKE NEWVARLIST VARLIST)
- (SETQ VARLIST NEWVARLIST
- C (RDIS (CDR C))
- VARLIST NIL
- C (RATF C)))
- (RETURN (COND (DONTDISREPIT C) (T ($RATDISREP C))))))
-
- (DEFUN XPTIMES (X Y) (IF $RATWTLVL (WTPTIMES X Y 0) (PTIMES X Y)))
-
- (DEFUN ALLSUBST00 (A B C)
- (COND ((EQUAL A B) C)
- (T (RATQUOTIENT (EVERYSUBST00 A (CAR B) (CAR C))
- (EVERYSUBST00 A (CAR B) (CDR C))))))
-
- (DEFUN EVERYSUBST00 (X I Z)
- (SLOOP WITH ANS = (RZERO)
- FOR (EXP COEF) ON (EVERYSUBST I Z *ALPHA) BY 'PT-RED
- DO (SETQ ANS (RATPLUS ANS (RATTIMES (CONS COEF 1) (RATEXPT X EXP) T)))
- FINALLY (RETURN ANS)))
-
- (DEFUN EVERYSUBST0 (X I Z)
- (SLOOP WITH ANS = (PZERO)
- FOR (EXP COEF) ON (EVERYSUBST I Z *ALPHA) BY 'PT-RED
- DO (SETQ ANS (PPLUS ANS (XPTIMES COEF (PEXPT X EXP))))
- FINALLY (RETURN ANS)))
-
- (DEFUN EVERYSUBST1 (A B MAXPOW)
- (SLOOP FOR (EXP COEF) ON (P-TERMS B) BY 'PT-RED
- FOR PART = (EVERYSUBST A COEF MAXPOW)
- NCONC (IF (= 0 EXP) PART
- (EVERYSUBST2 PART (MAKE-POLY (P-VAR B) EXP 1)))))
-
- (DEFUN EVERYSUBST2 (L H)
- (DO ((PTR L (CDDR PTR)))
- ((NULL PTR) L)
- (SETF (CADR PTR) (PTIMES H (CADR PTR)))))
-
-
- (DEFUN PAIROFF (L M)
- (COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M))))))
-
- ;(DEFUN PAIROFF (L M)
- ; ;(COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M)))))
- ; (let ((ans nil))
- ; (dolist (x m (nreconc ans l))
- ; (push x ans) (setq l (cdr l)))))
-
- (DEFUN EVERYSUBST (A B MAXPOW)
- (COND ((PCOEFP A)
- (COND ((EQN A 1) (LIST MAXPOW B))
- ((PCOEFP B)
- (LIST (SETQ MAXPOW
- (DO ((B B (QUOTIENT B A))
- (ANS 0 (f1+ ANS)))
- ((OR (GREATERP (ABS A) (ABS B))
- (EQN MAXPOW ANS))
- ANS)))
- (QUOTIENT B (SETQ MAXPOW (EXPT A MAXPOW)))
- 0
- (REMAINDER B MAXPOW)))
- (T (EVERYSUBST1 A B MAXPOW))))
- ((OR (PCOEFP B) (POINTERGP (CAR A) (CAR B))) (LIST 0 B))
- ((EQ (CAR A) (CAR B))
- (COND ((NULL (CDDDR A)) (EVERYPTERMS B (CADDR A) (CADR A) MAXPOW))
- (T (SUBSTFORSUM A B MAXPOW))))
- (T (EVERYSUBST1 A B MAXPOW))))
-
- (DEFUN EVERYPTERMS (X P N MAXPOW)
- (IF (LESSP (CADR X) N) (LIST 0 X)
- (PROG (K ANS Q PART)
- (SETQ K (CAR X))
- (SETQ X (CDR X))
- L (SETQ Q (MIN MAXPOW (QUOTIENT (CAR X) N)))
- M (COND ((EQN Q 0)
- (RETURN (COND ((NULL X) ANS)
- (T (CONS 0
- (CONS (PSIMP K X) ANS)))))))
- (SETQ PART (EVERYSUBST P (CADR X) Q))
- (SETQ ANS (NCONC (EVERYPTERMS1 PART K N (CAR X)) ANS))
- (SETQ X (CDDR X))
- (COND ((NULL X) (SETQ Q 0) (GO M)))
- (GO L))))
-
- (DEFUN EVERYPTERMS1 (L K N J)
- (DO ((PTR L (CDDR PTR)))
- ((NULL PTR) L)
- (SETF (CADR PTR)
- (PTIMES (PSIMP K (LIST (f- J (f* N (CAR PTR))) 1))
- (CADR PTR)))))
-
- (DEFUN SUBSTFORSUM (A B MAXPOW)
- (DO ((POW 0 (ADD1 POW))
- (QUOT) (zl-REM) (ANS))
- ((NOT (LESSP POW MAXPOW)) (LIST* MAXPOW B ANS))
- (DESETQ (QUOT zl-REM) (PDIVIDE B A))
- (UNLESS (AND (EQN (CDR QUOT) 1)
- (NOT (PZEROP (CAR QUOT)))
- (EQN (CDR zl-REM) 1))
- (RETURN (CONS POW (CONS B ANS))))
- (UNLESS (PZEROP (CAR zl-REM))
- (SETQ ANS (CONS POW (CONS (CAR zl-REM) ANS))))
- (SETQ B (CAR QUOT))))
-
- (DEFUN PRODCOEF (A B)
- (COND ((PCOEFP A)
- (COND ((PCOEFP B) (QUOTIENT B A)) (T (PRODCOEF1 A B))))
- ((PCOEFP B) (PZERO))
- ((POINTERGP (CAR A) (CAR B)) (PZERO))
- ((EQ (CAR A) (CAR B))
- (COND ((NULL (CDDDR A))
- (PRODCOEF (CADDR A) (PTERM (CDR B) (CADR A))))
- (T (SUMCOEF A B))))
- (T (PRODCOEF1 A B))))
-
- (DEFUN SUMCOEF (A B)
- (DESETQ (A B) (PDIVIDE B A))
- (IF (AND (EQUAL (CDR A) 1) (EQUAL (CDR B) 1))
- (CAR A)
- (PZERO)))
-
- (DEFUN PRODCOEF1 (A B)
- (SLOOP WITH ANS = (PZERO)
- FOR (BEXP BCOEF) ON (P-TERMS B) BY 'PT-RED
- FOR PART = (PRODCOEF A BCOEF)
- UNLESS (PZEROP PART)
- DO (SETQ ANS (PPLUS ANS (PSIMP (P-VAR B) (LIST BEXP PART))))
- FINALLY (RETURN ANS)))
-
- (DEFUN PUREPROD (X)
- (OR (ATOM X)
- (AND (NOT (ATOM (CDR X)))
- (NULL (CDDDR X))
- (PUREPROD (CADDR X)))))
-
- (DEFMFUN $BOTHCOEF (R VAR)
- (PROG (*VAR H VARLIST GENVAR $RATFAC)
- (UNLESS ($RATP R)
- (RETURN `((MLIST)
- ,(SETQ H (COEFF R VAR 1.))
- ((MPLUS) ,R ((MTIMES) -1 ,H ,VAR)))))
- (NEWVAR VAR)
- (SETQ H (AND VARLIST (CAR VARLIST)))
- (NEWVAR R)
- (SETQ VAR (CDR (RATREP* VAR)))
- (SETQ R (CDR (RATREP* R)))
- (AND H (SETQ H (CAADR (RATREP* H))))
- (COND ((AND H (OR (PCOEFP (CDR R)) (POINTERGP H (CADR R)))
- (EQUAL 1 (CDR VAR)))
- (SETQ VAR (BOTHPRODCOEF (CAR VAR) (CAR R)))
- (RETURN (LIST '(MLIST)
- (RDIS* (RATREDUCE (CAR VAR) (CDR R)))
- (RDIS* (RATREDUCE (CDR VAR) (CDR R))))))
- (T (MERROR "Bad arguments to BOTHCOEFF")))))
-
- ;COEFF OF A IN B
-
- (DEFUN BOTHPRODCOEF (A B)
- (LET ((C (PRODCOEF A B)))
- (IF (PZEROP C) (CONS (PZERO) B) (CONS C (PDIFFERENCE B (PTIMES C A))))))
-
- (DEFVAR ARGSFREEOFP NIL)
-
- (DEFMFUN ARGSFREEOF (VAR E)
- (LET ((ARGSFREEOFP T)) (FREEOF VAR E)))
-
- ;;; This is a version of freeof for a list first argument
- (defmfun $LFREEOF (l e) "FREEOF for a list first argument"
- (unless ($listp l) (merror "First argument must be a list"))
- (let ((exp ($TOTALDISREP e)))
- (dolist (var (margs l) T)
- (unless (freeof ($TOTALDISREP var) exp) (return nil)))))
-
- (DEFMFUN $FREEOF NARGS
- (PROG (L E)
- (SETQ L (MAPCAR #'$TOTALDISREP (NREVERSE (LISTIFY NARGS)))
- E (CAR L))
- LOOP (OR (SETQ L (CDR L)) (RETURN T))
- (IF (FREEOF (GETOPR (CAR L)) E) (GO LOOP))
- (RETURN NIL)))
-
- ;(DEFMFUN FREEOF (VAR E)
- ; (COND ((ALIKE1 VAR E) NIL)
- ; ((ATOM E) T)
- ; ((AND (OR (MEMQ (CAAR E) '(%PRODUCT %SUM %LAPLACE))
- ; (AND (EQ (CAAR E) '%INTEGRATE) (CDDDR E))
- ; (AND (EQ (CAAR E) '%LIMIT) (CDDR E)))
- ; (ALIKE1 VAR (CADDR E)))
- ; (FREEOFL VAR (CDDDR E)))
- ; ((EQ (CAAR E) '%AT)
- ; (COND ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'R))) NIL)
- ; ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'L))) T)
- ; (T (FREEOF VAR (CADR E)))))
- ; (ARGSFREEOFP (FREEOFL VAR (MARGS E)))
- ; (T (AND (FREEOF VAR (CAAR E)) (FREEOFL VAR (CDR E))))))
- ;Update from F302 --gsb
- (DEFUN FREEOF (VAR E)
- (COND ((ALIKE1 VAR E) NIL)
- ((ATOM E) T)
- ((AND (NOT ARGSFREEOFP) (ALIKE1 VAR (CAAR E))) NIL)
- ((AND (OR (MEMQ (CAAR E) '(%PRODUCT %SUM %LAPLACE))
- (AND (EQ (CAAR E) '%INTEGRATE) (CDDDR E))
- (AND (EQ (CAAR E) '%LIMIT) (CDDR E)))
- (ALIKE1 VAR (CADDR E)))
- (FREEOFL VAR (CDDDR E)))
- ((EQ (CAAR E) '%AT)
- (COND ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'R))) NIL)
- ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'L))) T)
- (T (FREEOF VAR (CADR E)))))
- ((AND (EQ (CAAR E) 'LAMBDA) (MEMQ VAR (CDADR E))) T)
- (ARGSFREEOFP (FREEOFL VAR (MARGS E)))
- (T (FREEOFL VAR (CDR E)))))
-
- (DEFUN FREEOFL (VAR L) (SLOOP FOR X IN L ALWAYS (FREEOF VAR X)))
-
- (DEFMFUN HAND-SIDE (E FLAG)
- (SETQ E (IF (EQ (CAAR E) 'MEQUAL) (NCONS E) (CDR E)))
- (MAPCAR #'(LAMBDA (U) (IF (EQ FLAG 'L) (CADR U) (CADDR U))) E))
-
- (COMMENT Subtitle RADCAN)
-
- (DEFMFUN $RADCAN (EXP)
- (COND ((MBAGP EXP) (CONS (CAR EXP) (MAPCAR '$RADCAN (CDR EXP))))
- (T (LET (($RATSIMPEXPONS T))
- (SIMPLIFY (LET (($EXPOP 0) ($EXPON 0))
- (RADCAN1 (FR1 EXP NIL))))))))
-
- (DEFUN RADCAN1 (*EXP)
- (COND ((ATOM *EXP) *EXP)
- (T (LET (($FACTORFLAG T) VARLIST GENVAR $RATFAC $NOREPEAT
- ($GCD (OR $GCD (CAR *GCDL*)))
- (RADCANP T))
- (NEWVAR *EXP)
- (SETQ *EXP (CDR (RATREP* *EXP)))
- (SETQ VARLIST
- (MAPCAR
- #'(LAMBDA (X) (COND
- ((ATOM X) X)
- (T (CONS (CAR X)
- (MAPCAR 'RADCAN1 (CDR X))))))
- VARLIST))
- (SPC0)
- (FR1 (RDIS *EXP) NIL)))))
-
- (DEFUN SPC0 ()
- (PROG (*V *LOGLIST)
- (IF (ALLATOMS VARLIST) (RETURN NIL))
- (SETQ VARLIST (MAPCAR (FUNCTION SPC1) VARLIST));make list of logs
- (SETQ *LOGLIST (FACTORLOGS *LOGLIST))
- (MAPC (FUNCTION SPC2) *LOGLIST) ;subst log factorizations
- (MAPC (FUNCTION SPC3) VARLIST GENVAR) ;expand exponents
- (MAPC (FUNCTION SPC4) VARLIST) ;make exponent list
- (DESETQ (VARLIST . GENVAR) (SPC5 *V VARLIST GENVAR))
- ;find expon dependencies
- (SETQ VARLIST (MAPCAR (FUNCTION RJFSIMP) VARLIST));restore radicals
- (MAPC (FUNCTION SPC7) VARLIST))) ;simplify radicals
-
- (DEFUN ALLATOMS (L)
- (SLOOP FOR X IN L ALWAYS (ATOM X)))
-
- (DEFUN RJFSIMP (X &AUX EXPON)
- (COND ((AND *RADSUBST $RADSUBSTFLAG) X)
- ((NOT (M$EXP? (SETQ X (LET ($LOGSIMP) (RESIMPLIFY X))))) X)
- ((MLOGP (SETQ EXPON (CADDR X))) (CADR EXPON))
- ((NOT (AND (MTIMESP EXPON) (OR $LOGSIMP *VAR))) X)
- (T (DO ((RISCHFLAG (AND *VAR (NOT $LOGSIMP) (NOT (FREEOF *VAR X))))
- (POWER (CDR EXPON) (CDR POWER))) ;POWER IS A PRODUCT
- ((NULL POWER) X)
- (COND ((NUMBERP (CAR POWER)))
- ((MLOGP (CAR POWER))
- (AND RISCHFLAG (CDR POWER) (RETURN X))
- (RETURN
- `((MEXPT) ,(CADAR POWER)
- ,(MULN (zl-REMOVE (CAR POWER) (CDR EXPON) 1)
- NIL))))
- (RISCHFLAG (RETURN X)))))))
-
- (DEFUN DSUBSTA (X Y ZL)
- (COND ((NULL ZL) ZL)
- (T (COND ((ALIKE1 Y (CAR ZL)) (RPLACA ZL X))
- ((NOT (ATOM (CAR ZL))) (DSUBSTA X Y (CDAR ZL))))
- (DSUBSTA X Y (CDR ZL))
- ZL)))
-
- (DEFUN RADSUBST (A B)
- (SETQ *EXP (ALLSUBST00 A B *EXP))
- (IF *RADSUBST (SETQ *EXP2 (ALLSUBST00 A B *EXP2))))
-
- (SETQ *VAR NIL)
-
- (DEFUN SPC1 (X)
- (COND ((MLOGP X) (PUTONLOGLIST X))
- ((AND (MEXPTP X) (NOT (EQ (CADR X) '$%E)))
- ($EXP (LIST '(MTIMES)
- (CADDR X)
- (PUTONLOGLIST (LIST '(%LOG SIMP RATSIMP)
- (CADR X))))))
- (T X)))
-
- (DEFUN PUTONLOGLIST (L)
- (UNLESS (MEMALIKE L *LOGLIST) (PUSH L *LOGLIST))
- L)
-
- (DEFUN SPC2 (P)
- (RADSUBST (RFORM (CDR P)) (RFORM (CAR P)))
- (DSUBSTA (CDR P) (CAR P) VARLIST))
-
- (DEFUN SPC2A (X) ;CONVERTS FACTORED
- ((LAMBDA (SUM) ;RFORM LOGAND TO SUM
- (IF (CDR SUM) (CONS '(MPLUS) SUM) ;OF LOGS
- (CAR SUM)))
- (MAPCAR (FUNCTION SPC2B) X)))
-
- (DEFUN SPC2B (X)
- (LET ((LOG `((%LOG SIMP RATSIMP IRREDUCIBLE) ,(PDIS (CAR X)))))
- (IF (EQUAL 1 (CDR X)) LOG
- (LIST '(MTIMES) (CDR X) LOG))))
-
- (DEFUN SPC3 (X V &AUX Y)
- (WHEN
- (AND (M$EXP? X)
- (NOT (ATOM (SETQ Y (CADDR X))))
- (MPLUSP (SETQ Y (EXPAND1 (IF *VAR ($PARTFRAC Y *VAR) Y)
- 10 10))))
- (SETQ Y (CONS '(MTIMES) (MAPCAR #'(LAMBDA (Z) ($RATSIMP ($EXP Z)))
- (CDR Y))))
- (RADSUBST (RFORM Y) (RGET V))
- (DSUBSTA Y X VARLIST)))
-
- (DEFUN SPC4 (X)
- (IF (AND (M$EXP? X)
- (NOT (MEMALIKE (CADDR X) *V)))
- (PUSH (CADDR X) *V)))
-
- (DEFUN RZCONTENT (R)
- (LET (((C1 P) (PCONTENT (CAR R)))
- ((C2 Q) (PCONTENT (CDR R))))
- (IF (PMINUSP P) (SETQ P (PMINUS P) C1 (CMINUS C1)))
- (CONS (CONS C1 C2) (CONS P Q))))
-
- ;;The GCDLIST looks like (( GCM1pair occurrencepair11 occurrencepair12 ...) ...
- ;;(GCMnpair occurrencepairn1 occurrencepairn2 ...))
- ;;where GCMpairs are lists of ratforms and prefix forms for the greatest common
- ;;multiple of the occurrencepairs. Each of these pairs is a list of a ratform
- ;;and a prefix form. The prefix form is a pointer into the varlist.
- ;;The occurrences are exponents of the base %E.
-
- (DEFUN SPC5 (VL OLDVARLIST OLDGENVAR &AUX GCDLIST VARLIST GENVAR)
- (DOLIST (V VL)
- (LET* ((((NIL . C) . R) (RZCONTENT (RFORM V)))
- (G (zl-ASSOC R GCDLIST)))
- (COND (G (SETF (CADR G) (PLCM C (CADR G)))
- (PUSH (LIST ($EXP V) C) (CDDR G)))
- (T (PUSH (LIST R C (LIST ($EXP V) C)) GCDLIST)))))
- (DOLIST (G GCDLIST)
- (LET ((RD (RDIS (CAR G))))
- (WHEN (AND (MLOGP RD) (MEMALIKE (CADR RD) OLDVARLIST))
- (PUSH (LIST (CADR RD) 1) (CDDR G)))
- (RPLACA G ($EXP (DIV RD (CADR G))))))
- (SPC5B GCDLIST OLDVARLIST OLDGENVAR))
-
- ;(DEFUN SPC5B (V VARLIST GENVAR)
- ; (DOLIST (L V)
- ; (DOLIST (X (CDDR L))
- ; (UNLESS (EQUAL (CADR L) (CADR X))
- ; (RADSUBST (RATEXPT (RFORM (CAR L))
- ; (CAR (QUOTIENT (CADR X) (CADR L))))
- ; (RFORM (CAR X))))))
- ; (CONS VARLIST GENVAR))
-
-
- (DEFUN SPC5B (V VARLIST GENVAR)
- (DOLIST (L V)
- (DOLIST (X (CDDR L))
- (UNLESS (EQUAL (CADR L) (CADR X))
- (RADSUBST (RATEXPT (RFORM (CAR L))
- (QUOTIENT (CADR L) (CADR X)))
- (RFORM (CAR X))))))
- (CONS VARLIST GENVAR))
-
- (DEFUN SPC7 (X)
- (IF (EQ X '$%I) (SETQ X '((MEXPT) -1 ((RAT) 1 2))))
- (WHEN (AND (MEXPTP X)
- (RATNUMP (CADDR X)))
- (LET ((RAD (RFORM X))
- (RBASE (RFORM (CADR X)))
- (EXPON (CADDR X)))
- (RADSUBST (RATEXPT RBASE (CADR EXPON))
- (RATEXPT RAD (CADDR EXPON))))))
-
-
- (defun goodform (l) ;;bad -> good
- (sloop for (exp coef) on l by 'pt-red
- collect (cons exp coef)))
-
- (defun factorlogs (l)
- (prog (negl posl maxpl maxnl maxn)
- (dolist (log l)
- (setq log
- (cons log (goodform
- (ratfact (rform (radcan1 (cadr log)))
- (function pfactor)))))
- (cond ((equal (caadr log) -1) (push log negl))
- (t (push log posl))))
- (setq negl (flsort negl) posl (flsort posl) l (append negl posl))
- (setq negl (mapcar (function cdr) negl)
- posl (mapcar (function cdr) posl))
- a (setq negl (zl-DELETE '((-1 . 1)) negl))
- (or negl
- (return (mapc #'(lambda (x) (rplacd x (spc2a (cdr x)))) l)))
- (setq maxnl (flmaxl negl)
- maxn (caaar maxnl))
- b (setq maxpl (flmaxl posl))
- (cond ((and maxpl (flgreat (caaar maxpl) maxn))
- (setq posl (flred posl (caaar maxpl)))
- (go b))
- ((and maxpl
- (not (equal (caaar maxpl) maxn)))
- (setq maxpl nil)))
- (cond ((and (flevenp maxpl) (not (flevenp maxnl)))
- (mapc #'(lambda (fp) (rplaca (car fp) (pminus (caar fp)))
- (cond ((oddp (cdar fp))
- (zl-DELETE '(-1 . 1) fp)
- (setq negl (zl-DELETE fp negl))
- (and (cdr fp) (push (cdr fp) posl)))))
- maxnl)
- (go a))
- (t (setq posl (flred posl maxn)
- negl (flred negl maxn))
- (go a)))))
-
- (defun flevenp (pl)
- (sloop for l in pl never (oddp (cdar l))))
-
- (defun flred (pl p)
- (MAPL #'(lambda (x) (if (equal p (caaar x))
- (rplaca x (cdar x))))
- pl)
- (zl-DELETE nil pl))
-
- (defun flmaxl (fpl) ;lists of fac. polys
- (cond ((null fpl) nil)
- (t (do ((maxl (list (car fpl))
- (cond ((equal (caaar maxl) (caaar ll))
- (cons (car ll) maxl))
- ((flgreat (caaar maxl) (caaar ll)) maxl)
- (t (list (car ll)))))
- (ll (cdr fpl) (cdr ll)))
- ((null ll) maxl)))))
-
- (defun flsort (fpl)
- (mapc #'(lambda (x) (rplacd x (sortcar (cdr x) #'flgreat)))
- fpl))
-
- (defun nmt (p any)
- (cond ((pcoefp p)
- (if (or any (cminusp p)) 1 0))
- (t (sloop for lp on (p-terms p) by 'pt-red
- sum (nmt (cadr lp) any)))))
-
- (defun nmterms (p)
- (cond ((equal p -1) (cons 0 0))
- (t (cons (nmt p nil) (nmt p t)))))
-
- (defun flgreat (p q)
- (let ((pn (nmterms p)) (qn (nmterms q)))
- (cond ((> (car pn) (car qn)) t)
- ((< (car pn) (car qn)) nil)
- ((> (cdr pn) (cdr qn)) t)
- ((< (cdr pn) (cdr qn)) nil)
- (t (flgreat1 p q)))))
-
- (defun flgreat1 (p q)
- (cond ((numberp p)
- (cond ((numberp q) (greaterp p q))
- (t nil)))
- ((numberp q) t)
- ((pointergp (car p) (car q)) t)
- ((pointergp (car q) (car p)) nil)
- ((> (cadr p) (cadr q)) t)
- ((< (cadr p) (cadr q)) nil)
- (t (flgreat1 (caddr p) (caddr q)))))
-
-
- ; Undeclarations for the file:
- #-nil
- (DECLARE-TOP(NOTYPE NARGS))
-
-